home *** CD-ROM | disk | FTP | other *** search
/ SGI Developer Toolbox 6.1 / SGI Developer Toolbox 6.1 - Disc 4.iso / public / SciAn / src / ScianP3DUnfmt.f < prev    next >
Text File  |  1994-08-01  |  11KB  |  337 lines
  1. c  Tzong-Yow Hwu
  2. c Fortran routines for use in p3d reader for fortran unformatted data files
  3.       subroutine foropn(lun, iname, length, opstat)
  4.     integer lun, iname(1800), length, opstat 
  5. c       lun: the logical unit number for the opened file
  6. c       iname: the ascii code of the file name
  7. c       length: the length of the iname integer array
  8. c       opstat: an error indicator, a value of 0 indicates an error on open
  9. c             and other values O.K.
  10. c
  11.     character*180 sname
  12.     integer done, notdone
  13. c
  14.     parameter(done = 1, notdone = 0)
  15.     opstat = notdone 
  16. c
  17. c Mapping the file name to sname
  18.     do istep=1,length
  19.           sname(istep:istep)=char(iname(istep))
  20.         end do
  21.         open(unit=lun, err=100, file=sname(1:length), status='old',
  22.      &       access='sequential', form='unformatted')
  23.     opstat = done
  24. 100     return
  25. c
  26.       end
  27. c
  28. c
  29.       subroutine forcls(lun)
  30.     integer lun
  31. c
  32.     close(unit=lun)
  33.     return
  34.       end
  35. c
  36. c
  37. c  For reading ngrid in fortran unformatted file
  38.       subroutine rngrid(lun, ngrid, opstat) 
  39.     integer lun, ngrid, opstat 
  40. c       lun:     logical unit number connected to the opened xyz file
  41. c       ngrid:   ngrid to be read
  42. c       opstat:  error indicator
  43. c
  44.     integer*4 status
  45.     integer done, notdone, eofile
  46.     parameter(done = 1, notdone = 0, eofile=-1)
  47. c
  48.     opstat = notdone 
  49.     read(unit=lun, err=200, iostat=status) ngrid
  50. c
  51.     opstat = done 
  52. 200     if (status .LT. 0) then
  53.       opstat = eofile
  54.         end if
  55.         return
  56.       end
  57. c
  58. c
  59. c  to use this routine, indims must be allocated as an int array of size
  60. c  ngrid*ndim where ndim is the number of dimensions for xyz and solution
  61. c  file, and number of dimensions plus one(for nvar) for function file
  62. c  For reading indims in fortran unformatted file
  63.       subroutine rddims(lun, ndim, ngrid, indims, opstat) 
  64.     integer lun, ndim, ngrid, opstat 
  65.     integer indims(ndim*ngrid)
  66. c       lun:     logical unit number connected to the opened xyz file
  67. c       ndim:    number of dimensions
  68. c       ngrid:   ngrid to be read
  69. c       indims:  dimension array
  70. c       opstat:  error indicator
  71. c
  72.     integer*4 status
  73.     integer done, notdone, eofile
  74.     parameter(done = 1, notdone = 0, eofile=-1)
  75.     integer i, j, k, n
  76. c
  77.     opstat = notdone 
  78.     read(unit=lun, err=300, iostat=status) 
  79.      &       ((indims(n*ndim+i), i = 1, ndim), n = 0, ngrid - 1)
  80. c
  81.     opstat = done 
  82. 300     if (status .LT. 0) then
  83.       opstat = eofile
  84.         endif
  85.         return
  86.       end
  87. c
  88. c
  89. c  For reading grid values in fortran unformatted file
  90. c  Reading a grid values of a single grid
  91.       subroutine rdgrid
  92.      &(lun, ndim, indims, isiblk, iblank, iperm, gdvals, size, opstat) 
  93.     integer lun, ndim, indims(ndim), isiblk, iperm, opstat
  94.     integer*4 size
  95.     integer iblank(size)
  96.     real gdvals(size*ndim) 
  97. c       lun:     logical unit number connected to the opened xyz file
  98. c       ndim:    number of dimensions
  99. c       indims:  indirect dimension array
  100. c       isiblk:  is there a iblank in the grid file
  101. c       iblank:  iblank array
  102. c       iperm:   the arrangement of the grid value in whole or plane
  103. c       gdvals:  grid values
  104. c       size:    the size of one component of the grid
  105. c       opstat:  error indicator
  106. c
  107.     integer done, notdone, whole, yes
  108.     parameter(done = 1, notdone = 0, whole=0, yes=1)
  109.     integer i, j, k, n
  110. c
  111.     opstat = notdone 
  112. c    
  113.         if (iperm .EQ. whole) then
  114. c       grid data is arranged in whole
  115.       if (isiblk .EQ. yes) then
  116. c       grid file contains iblank values
  117.             if (ndim .EQ. 1) then
  118.               read(unit=lun, err=400) 
  119.      &          (gdvals(i), i=1, indims(1)), 
  120.      &          (iblank(i), i=1, indims(1))
  121.         else if (ndim .EQ. 2) then
  122.           read(unit=lun, err=400)
  123.      &        (((gdvals(n*size+i*indims(2)+j), i=0,indims(1) - 1),
  124.      &                             j=1,indims(2)),n=0,ndim-1),
  125.      &        ((iblank(i*indims(2)+j), i=0,indims(1)-1), j=1,indims(2))
  126.         else if (ndim .EQ. 3) then
  127.           read(unit=lun, err=400)
  128.      &        ((((gdvals(n*size+i*indims(2)*indims(3)+j*indims(3)+k),
  129.      &        i=0,indims(1)-1),j=0,indims(2)-1),k=1,indims(3)),
  130.      &        n=0,ndim-1),
  131.      &        (((iblank(i*indims(2)*indims(3)+j*indims(3)+k),
  132.      &        i=0,indims(1)-1),j=0,indims(2)-1),k=1,indims(3))
  133.         else
  134.           go to 400
  135.             end if
  136. c
  137.       else
  138. c
  139. c       grid file contains no iblank values
  140. c
  141.             if (ndim .EQ. 1) then
  142.               read(unit=lun, err=400) 
  143.      &          (gdvals(i), i=1, indims(1)) 
  144.         else if (ndim .EQ. 2) then
  145.           read(unit=lun, err=400)
  146.      &        (((gdvals(n*size+i*indims(2)+j), i=0,indims(1) - 1),
  147.      &                             j=1,indims(2)),n=0,ndim-1)
  148.         else if (ndim .EQ. 3) then
  149.           read(unit=lun, err=400)
  150.      &        ((((gdvals(n*size+i*indims(2)*indims(3)+j*indims(3)+k),
  151.      &        i=0,indims(1)-1),j=0,indims(2)-1),k=1,indims(3)),
  152.      &        n=0,ndim-1)
  153.         else
  154.           go to 400
  155.             end if
  156.       endif
  157. c
  158.     else
  159. c       grid data is arranged in plane
  160. c
  161.       if (isiblk .EQ. yes) then
  162. c       grid file contains iblank values
  163.             if (ndim .EQ. 1) then
  164.               read(unit=lun, err=400) 
  165.      &          (gdvals(i), i=1, indims(1)), 
  166.      &          (iblank(i), i=1, indims(1))
  167.         else if (ndim .EQ. 2) then
  168.           read(unit=lun, err=400)
  169.      &        (((gdvals(n*size+i*indims(2)+j), i=0,indims(1) - 1),
  170.      &                             j=1,indims(2)),n=0,ndim-1),
  171.      &        ((iblank(i*indims(2)+j), i=0,indims(1)-1), j=1,indims(2))
  172.         else if (ndim .EQ. 3) then
  173.           do k = 1, indims(3)
  174.             read(unit=lun, err=400)
  175.      &          (((gdvals(n*size+i*indims(2)*indims(3)+j*indims(3)+k),
  176.      &          i=0,indims(1)-1),j=0,indims(2)-1), n=0,ndim-1),
  177.      &          ((iblank(i*indims(2)*indims(3)+j*indims(3)+k),
  178.      &          i=0,indims(1)-1),j=0,indims(2)-1)
  179.           end do
  180.         else
  181.           go to 400
  182.             end if
  183. c
  184.       else
  185. c
  186. c       grid file contains no iblank values
  187. c
  188.             if (ndim .EQ. 1) then
  189.               read(unit=lun, err=400) 
  190.      &          (gdvals(i), i=1, indims(1)) 
  191.         else if (ndim .EQ. 2) then
  192.           read(unit=lun, err=400)
  193.      &        (((gdvals(n*size+i*indims(2)+j), i=0,indims(1) - 1),
  194.      &                             j=1,indims(2)),n=0,ndim-1)
  195.         else if (ndim .EQ. 3) then
  196.           do k = 1, indims(3)
  197.             read(unit=lun, err=400)
  198.      &          (((gdvals(n*size+i*indims(2)*indims(3)+j*indims(3)+k),
  199.      &          i=0,indims(1)-1),j=0,indims(2)-1), n=0,ndim-1)
  200.           end do
  201.         else
  202.           go to 400
  203.             end if
  204.       endif
  205. c
  206.     endif
  207. c
  208.     opstat = done 
  209. 400     return
  210.       end
  211. c
  212. c
  213. c  For reading solution values in fortran unformatted file
  214. c  Reading solution values of a single grid
  215.       subroutine rdsolu
  216.      &(lun, ndim, indims, iperm, slvals, size, opstat) 
  217.     integer lun, ndim, indims(ndim), iperm, opstat
  218.     integer*4 size
  219.     real slvals(size*(ndim+2)) 
  220. c             ndime+2 since includes density and pressure
  221. c       lun:     logical unit number connected to the opened Q file
  222. c       ndim:    number of dimensions
  223. c       indims:  indirect dimension array
  224. c       iperm:   the arrangement of the solution values in whole or plane
  225. c       slvals:  density, pressure, and solution values
  226. c       size:    the size of one component of the solution values 
  227. c       opstat:  error indicator
  228. c
  229.     integer done, notdone, whole
  230.     parameter(done = 1, notdone = 0, whole=0)
  231.     integer i, j, k, n
  232. c
  233.     opstat = notdone 
  234. c    
  235.         if (ndim .EQ. 1) then
  236.           read(unit=lun, err=500) 
  237.      &      ((slvals(n*size+i), i=1, indims(1)), n = 0, 2) 
  238.     else if (ndim .EQ. 2) then
  239.       read(unit=lun, err=500)
  240.      &    (((slvals(n*size+i*indims(2)+j), i=0,indims(1) - 1),
  241.      &                         j=1,indims(2)),n=0,3)
  242.     else if (ndim .EQ. 3) then
  243.           if (iperm .EQ. whole) then
  244. c           solution data is arranged in whole
  245.         read(unit=lun, err=500)
  246.      &      ((((slvals(n*size+i*indims(2)*indims(3)+j*indims(3)+k),
  247.      &      i=0,indims(1)-1),j=0,indims(2)-1),k=1,indims(3)),
  248.      &      n=0,4)
  249.       else
  250. c           solution data is arranged in plane
  251.         do k = 1, indims(3)
  252.           read(unit=lun, err=500)
  253.      &        (((slvals(n*size+i*indims(2)*indims(3)+j*indims(3)+k),
  254.      &        i=0,indims(1)-1),j=0,indims(2)-1), n=0,4)
  255.         end do
  256.       end if
  257.     else
  258.       go to 500
  259.         end if
  260. c
  261.     opstat = done 
  262. 500     return
  263.       end
  264. c
  265. c
  266. c     for use to read time data from solution q files
  267.       subroutine rdtime(lun, time, opstat)
  268.     integer lun, opstat
  269.     real time
  270. c       lun:     logical unit number connected to the opened Q file
  271. c       time:    the time of the dataset
  272. c       opstat:  error indicator
  273. c
  274. c       useless data to be discarded
  275.         real fsmach, alpha, re 
  276.     integer done, notdone, whole
  277.     parameter(done = 1, notdone = 0, whole=0)
  278. c
  279.     opstat = notdone 
  280.     read(unit=lun, err=600) fsmach, alpha, re, time
  281.         opstat = done    
  282. 600     return
  283.       end
  284. c
  285. c
  286. c  For reading function values in fortran unformatted file
  287. c  Reading function values of a single grid
  288.       subroutine rdfunc
  289.      &(lun, ndim, indims, nvar, iperm, fnvals, size, opstat) 
  290.     integer lun, ndim, indims(ndim), nvar, iperm, opstat
  291.     integer*4 size
  292.     real fnvals(size*nvar) 
  293. c       lun:     logical unit number connected to the opened function file
  294. c       ndim:    number of dimensions
  295. c       indims:  indirect dimension array
  296. c       nvar:    rank: value of 1 means scalar, more means vector 
  297. c       iperm:   the arrangement of the solution values in whole or plane
  298. c       funcvals:  function values of n variables 
  299. c       size:    the size of the function values 
  300. c       opstat:  error indicator
  301. c
  302.     integer done, notdone, whole
  303.     parameter(done = 1, notdone = 0, whole=0)
  304.     integer i, j, k, n
  305. c
  306.     opstat = notdone 
  307. c    
  308.         if (ndim .EQ. 1) then
  309.           read(unit=lun, err=700) 
  310.      &      ((fnvals(n*size+i), i=1, indims(1)), n = 0, nvar-1) 
  311.     else if (ndim .EQ. 2) then
  312.       read(unit=lun, err=700)
  313.      &    (((fnvals(n*size+i*indims(2)+j), i=0,indims(1) - 1),
  314.      &                         j=1,indims(2)),n=0,nvar-1)
  315.     else if (ndim .EQ. 3) then
  316.           if (iperm .EQ. whole) then
  317. c           solution data is arranged in whole
  318.         read(unit=lun, err=700)
  319.      &      ((((fnvals(n*size+i*indims(2)*indims(3)+j*indims(3)+k),
  320.      &      i=0,indims(1)-1),j=0,indims(2)-1),k=1,indims(3)),
  321.      &      n=0,nvar-1)
  322.       else
  323. c           solution data is arranged in plane
  324.         do k = 1, indims(3)
  325.           read(unit=lun, err=700)
  326.      &        (((fnvals(n*size+i*indims(2)*indims(3)+j*indims(3)+k),
  327.      &        i=0,indims(1)-1),j=0,indims(2)-1), n=0,nvar-1)
  328.         end do
  329.       end if
  330.     else
  331.       go to 700
  332.         end if
  333. c
  334.     opstat = done 
  335. 700     return
  336.       end
  337.